{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}

module RenderEngine 
( worldMinX
, worldMaxX
, worldMinY
, worldMaxY
, worldWidth
, worldHeight
, worldFarZ
, worldNearZ
, wallClockTimes
, tickDurations
, mousePositions
, leftButtonDowns
, rightButtonDowns
, keyDowns
, run
, SensorsSample(..)
, Sensors
, Path
, Picture
, Pictures
, emptyPic        
, lineStrip       
, lineLoop        
, solidPolygon    
, points          
, withPointRadius 
, withLineSize    
, withColor       
, withName        
, translatedBy    
, scaledBy        
, rotatedBy       
, over            
, arcPath
, ellipsePath
, circlePath
, rectPath
, solidPolygonAt
, Key(..)
, SpecialKey(..)
, traceThreadId
)
where

import Math
import Color
import Point2D
import Vector2D
import Vector4D
import Projectable

import StreamEngine

import System.Exit

import Data.IORef
import Data.Maybe
import Data.Array.Unboxed
import Data.Monoid

import Graphics.UI.GLFW (Key(..), SpecialKey(..))

import qualified Graphics.UI.GLFW as GLFW
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.Rendering.OpenGL.GLU as GLU
import Graphics.Rendering.OpenGL (($=), ($~),get)

import Control.Applicative
import Control.Monad
import Control.Exception

import System.IO.Unsafe

import Data.VectorSpace hiding (Scalar)
import qualified Data.VectorSpace as VS
import Data.AffineSpace

--import Control.Applicative.Infix

import qualified Data.Stream as S
import Data.Stream ((<:>))

import Control.Concurrent
import Control.Concurrent.Chan
import Control.Parallel.Strategies

import Debug.Trace

-------------------------------------------------------------------------------

windowWidth  :: Int
windowHeight :: Int
windowDepth  :: Int

windowWidth = 800 -- physical pixels
windowHeight = 600 -- physical pixels
windowDepth = 16 -- bits

-------------------------------------------------------------------------------

worldMinX, worldMinY, worldMaxX, worldMaxY, 
  worldWidth, worldHeight, worldFarZ, worldNearZ :: Scalar

worldMinX = -400 -- logical units
worldMaxX =  400 -- logical units
worldMinY = -300 -- logical units
worldMaxY =  300 -- logical units
worldWidth = worldMaxX - worldMinX  -- logical units
worldHeight = worldMaxY - worldMinY -- logical units
worldFarZ = 1 
worldNearZ = 0

-------------------------------------------------------------------------------
-- Convert OpenGL screen position to a world position

screenToWorldPosition :: GL.Position -> IO Point2
screenToWorldPosition (GL.Position x y) = 
  do
    viewport@(_,GL.Size _ height) <- get GL.viewport
    modelviewMatrix <- getMatrix $ GL.Modelview 0
    projectionMatrix <- getMatrix  $ GL.Projection
    let pos3 = GL.Vertex3 (fromIntegral x) (fromIntegral height - fromIntegral y) 0
    GL.Vertex3 vx vy _ <- GLU.unProject pos3 
                             modelviewMatrix projectionMatrix viewport
    return $ point2 (realToFrac vx) (realToFrac vy)
  where
    getMatrix :: GL.MatrixMode -> IO(GL.GLmatrix GL.GLdouble)
    getMatrix mode = get $ GL.matrix $ Just mode

-------------------------------------------------------------------------------
-- Quick and dirty frames per second counter

type FPS = IORef(Scalar,Int)

initFPS :: IO FPS
initFPS = do
  t0 <- get GLFW.time
  newIORef (t0,0)

updateFPS :: FPS -> IO()
updateFPS fps = do
  (t1,c1) <- readIORef fps
  t2 <- get GLFW.time
  let c2 = c1+1
      dt = t2-t1
  if dt >= 1
   then do
     let text = show (round $ 1000000*dt / fromIntegral c2::Int) ++ " microsec per frame = " 
                ++  show (round $ fromIntegral c2 / dt::Int) ++ " frames per sec"
     GLFW.windowTitle $= text
     --print text
     writeIORef fps (t2,0)
   else
     writeIORef fps (t1,c2)

-------------------------------------------------------------------------------
 
initGfx :: IO ()
initGfx = 
  do
    GLFW.initialize
    GLFW.disableSpecial GLFW.AutoPollEvent
    GLFW.openWindowHint $= (GLFW.FSAASamples,16)
    GLFW.openWindow (GL.Size (fromIntegral windowWidth) (fromIntegral windowHeight))
--    GLFW.openWindow (GL.Size 800 1200)
                    [GLFW.DisplayDepthBits windowDepth] GLFW.Window
    GLFW.swapInterval $= 1
    GLFW.windowTitle $= "Pong Test"
    GLFW.windowSizeCallback $= onWindowResized
    GL.shadeModel $= GL.Smooth
    GL.lineSmooth $= GL.Disabled
    GL.lineSmooth $= GL.Enabled
    GL.blend $= GL.Enabled
    GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
    GL.lineWidth $= 1.5
--    GL.polygonSmooth $= GL.Enabled
    GL.clearColor $= GL.Color4 0 0 0 0
    GL.pointSmooth $= GL.Enabled
    GL.pointSize $= 1.5
    GL.clearDepth $= realToFrac worldFarZ
    GL.depthRange $= (realToFrac worldNearZ, realToFrac worldFarZ)
    GL.depthFunc $= Just GL.Lequal
    GL.matrixMode $= GL.Projection
    GL.loadIdentity
    GL.ortho (realToFrac worldMinX) (realToFrac worldMaxX) 
             (realToFrac worldMinY) (realToFrac worldMaxY) 
             (realToFrac worldNearZ) (realToFrac worldFarZ)
    GL.matrixMode $= GL.Modelview 0
    GL.loadIdentity

  where
    onWindowResized (GL.Size wndWidth wndHeight) = do
      let ww = fromIntegral wndWidth
          wh = fromIntegral wndHeight
          cw = worldWidth
          ch = worldHeight
          sw = wh * cw / ch
          sh = ww * ch / cw
      if sw < ww 
        then GL.viewport $= (GL.Position (round $ (ww-sw)/2) 0, GL.Size (round sw) (round wh))
        else GL.viewport $= (GL.Position 0 (round $ (wh-sh)/2), GL.Size (round ww) (round sh))

termGfx :: IO ()
termGfx = do
  GLFW.terminate

-------------------------------------------------------------------------------

exited :: IO Bool
exited = do
  windowOpenStatus <- get $ GLFW.windowParam GLFW.Opened
  return $ windowOpenStatus == 0

-------------------------------------------------------------------------------

instance Bounded GLFW.Key where
  minBound = CharKey '\0'
  maxBound = SpecialKey KP_ENTER

-------------------------------------------------------------------------------

instance Ix GLFW.Key where
 range (lo,hi) = [lo..hi]
 index (lo,hi) i = index (fromEnum lo, fromEnum hi) (fromEnum i)
 inRange (lo,hi) i = inRange (fromEnum lo, fromEnum hi) (fromEnum i)

-------------------------------------------------------------------------------

data SensorsSample = SS { wallClockTime :: !Time
                        , isLeftButtonDown :: !Bool
                        , isRightButtonDown :: !Bool
                        , mousePosition :: !Point2
                        , isKeyDown :: !(UArray GLFW.Key Bool)
                        } deriving Show

type Sensors = Signal SensorsSample

-------------------------------------------------------------------------------

keyBounds :: (Key,Key)
keyBounds = (minBound,maxBound)

-------------------------------------------------------------------------------

isBtnPressed :: GLFW.MouseButton -> IO Bool
isBtnPressed btn = (==GLFW.Press) <$> GLFW.getMouseButton btn

isKeyPressed :: GLFW.Key -> IO Bool
isKeyPressed key = (==GLFW.Press) <$> GLFW.getKey key

sampleSensor :: IO SensorsSample
sampleSensor = do
  --GLFW.waitEvents
  GLFW.pollEvents
  x <- exited
  when x exitSuccess
  mpt <- get GLFW.mousePos >>= screenToWorldPosition
  lbd <- isBtnPressed GLFW.ButtonLeft
  rbd <- isBtnPressed GLFW.ButtonRight
  keys <- mapM isKeyPressed (range keyBounds)
  wct <- get GLFW.time
  return $! SS wct lbd rbd mpt (listArray keyBounds keys)  

-------------------------------------------------------------------------------

wallClockTimes :: Sensors -> Signal Time
wallClockTimes ss = wallClockTime <$> ss

-------------------------------------------------------------------------------

leftButtonDowns :: Sensors -> Trigger
leftButtonDowns ss = rising $ isLeftButtonDown <$> ss

-------------------------------------------------------------------------------

rightButtonDowns :: Sensors -> Trigger
rightButtonDowns ss = rising $ isRightButtonDown <$> ss

-------------------------------------------------------------------------------

keyDowns :: Key -> Sensors -> Trigger
keyDowns key ss = rising $ (!key) . isKeyDown <$> ss

-------------------------------------------------------------------------------

mousePositions :: Sensors -> Signal Point2
mousePositions ss = mousePosition <$> ss

-------------------------------------------------------------------------------

tickDurations :: Sensors -> Signal Duration
tickDurations ss = 0 <:> dts
  where
    dts = S.tail wcts ^-^ wcts
    wcts = wallClockTime <$> ss
{-    dumpTick dt = trace (show dtms) dt
        where
          dtms :: Int
          dtms = round (dt * 1000) -}


-------------------------------------------------------------------------------

type Path = [Point2]
--type PathUV    = [(Point2,Point2)]

-- Simple 2D scene
data Picture
  = Empty
  | LineStrip !Path
  | LineLoop !Path
  | SolidPolygon !Path
  | Points !Path
  | WithPointRadius !Radius !Picture
  | WithLineSize !Scalar !Picture
  | WithColor !Color !Picture
  | WithName !Int !Picture
  | TranslatedBy !Vector2 !Picture
  | ScaledBy !Vector2 !Picture
  | RotatedBy !Angle !Picture
  | Over !Picture !Picture
  deriving Show

instance NFData Picture where
  rnf Empty = ()
  rnf (LineStrip path) = rnf path 
  rnf (LineLoop path) = rnf path 
  rnf (SolidPolygon path) = rnf path 
  rnf (Points path) = rnf path 
  rnf (WithPointRadius _ p) = rnf p 
  rnf (WithLineSize _ p) = rnf p
  rnf (WithColor _ p) = rnf p
  rnf (WithName _ p) = rnf p
  rnf (TranslatedBy _ p) = rnf p 
  rnf (ScaledBy _ p) = rnf p
  rnf (RotatedBy _ p) = rnf p
  rnf (Over p1 p2) = rnf p1 `seq` rnf p2

infixl 1 `Over`

instance Monoid Picture where
  mempty = Empty
  mappend = Over

emptyPic        :: Picture
lineStrip       :: Path -> Picture
lineLoop        :: Path -> Picture
solidPolygon    :: Path -> Picture
points          :: Path -> Picture
withPointRadius :: Radius -> Picture -> Picture
withLineSize    :: Scalar -> Picture -> Picture
withColor       :: Color -> Picture -> Picture
withName        :: Int -> Picture -> Picture
translatedBy    :: Vector2 -> Picture -> Picture
scaledBy        :: Vector2 -> Picture -> Picture
rotatedBy       :: Angle -> Picture -> Picture
over            :: Picture -> Picture -> Picture

emptyPic        = Empty
lineStrip       = LineStrip
lineLoop        = LineLoop
solidPolygon    = SolidPolygon
points          = Points
withPointRadius = WithPointRadius 
withLineSize    = WithLineSize    
withColor       = WithColor       
withName        = WithName        
translatedBy    = TranslatedBy    
scaledBy        = ScaledBy        
rotatedBy       = RotatedBy       
over            = Over            

arcPath :: Scalar -> Scalar -> Scalar -> Scalar -> Int -> Path
arcPath startAngle endAngle radiusX radiusY steps = 
  [ point2 (radiusX * cos angle) (radiusY * sin angle) 
  | i <- [0..steps]
  , let angle = lerp startAngle endAngle (fromIntegral i / fromIntegral steps)
  ]

ellipsePath :: Scalar -> Scalar -> Int -> Path
ellipsePath = arcPath 0 (2*pi) 

circlePath :: Scalar -> Int -> Path
circlePath radius = ellipsePath radius radius

rectPath :: Scalar -> Scalar -> Path
rectPath width height = [ point2 l t
                        , point2 r t
                        , point2 r b
                        , point2 l b]
  where
    hw = width / 2
    hh = height / 2
    l = -hw
    r = hw
    b = hh
    t = -hh

solidPolygonAt :: Point2 -> Color -> Path -> Picture
solidPolygonAt point color = 
  translatedBy (point .-. origin2) .
  withColor color .
  solidPolygon

-------------------------------------------------------------------------------

toGLd :: Scalar -> GL.GLdouble 
toGLd x = realToFrac x 

toGLf :: Scalar -> GL.GLfloat 
toGLf x = realToFrac x 

vertexPF :: (ProjectX a, ProjectY a) => a  -> IO()
vertexPF v = GL.vertex $ GL.Vertex2 (toGLd $ getX v) (toGLd $ getY v)

glColor4f :: Scalar -> Scalar -> Scalar -> Scalar -> GL.Color4 GL.GLfloat
glColor4f r g b a = GL.Color4 (toGLf r) (toGLf g) (toGLf b) (toGLf a)

-------------------------------------------------------------------------------

renderWith :: GL.StateVar a -> (a->a) -> Picture -> IO ()
renderWith attr modifier pic = 
  do
    oldValue <- get attr
    attr $~ modifier
    render pic
    attr $= oldValue

-------------------------------------------------------------------------------

renderRoot :: Picture -> IO()
renderRoot pic = GL.clear [GL.ColorBuffer] >> render pic >> GLFW.swapBuffers

-------------------------------------------------------------------------------

render :: Picture -> IO()
render picture = 
  case picture of 
    LineStrip path -> 
      GL.renderPrimitive GL.LineStrip (mapM_ vertexPF path)

    LineLoop path -> 
      GL.renderPrimitive GL.LineLoop (mapM_ vertexPF path)

    Points path -> 
      GL.renderPrimitive GL.Points (mapM_ vertexPF path)

    SolidPolygon path ->
      GL.renderPrimitive GL.Polygon (mapM_ vertexPF path)

    WithPointRadius radius pic -> 
      renderWith GL.pointSize (const $ realToFrac radius) pic

    WithLineSize size pic -> 
      renderWith GL.lineWidth (const $ realToFrac size) pic

    WithColor (RGBA (V4 r g b a)) pic ->
      renderWith GL.currentColor (const $ glColor4f r g b a) pic

    TranslatedBy (V2 tx ty) pic ->
      GL.unsafePreservingMatrix $ 
        do 
          GL.translate (GL.Vector3 (toGLd tx) (toGLd ty) 0)
          render pic
	
    RotatedBy angle pic ->
      GL.unsafePreservingMatrix $ 
        do
	  GL.rotate (toGLd $ toDegrees angle) (GL.Vector3 0 0 (-1))
          render pic

    ScaledBy (V2 sx sy) pic ->
      GL.unsafePreservingMatrix $ 
        do
	  GL.scale (toGLd sx) (toGLd sy) 1
          render pic

    WithName name pic ->
      GL.withName (GL.Name $ fromIntegral name) (render pic)

    pic1 `Over` pic2 -> render pic2 >> render pic1

    Empty -> return ()

-------------------------------------------------------------------------------

type Pictures = [Picture]

traceThreadId :: a -> a
traceThreadId = trace (show . unsafePerformIO $ myThreadId)

writeStrictListToChan :: NFData a => Chan a -> [a] -> IO ()
writeStrictListToChan _    [] = return ()
writeStrictListToChan chan (a:as) = do
  let a' = a `using` rnf
  writeChan chan $! a'
  writeStrictListToChan chan as

run :: (Sensors -> Pictures) -> IO ()
run simulation = bracket_ initGfx termGfx runGfx
  where
{-
    runGfx = getSensorSignal >>= 
             execute . 
             map renderRoot . 
             simulation
-}

    runGfx = do
      picChan <- newChan
      snsChan <- newChan
      fps <- initFPS
      writeChan picChan (Just Empty)
      let simLoop = do
               GLFW.initialize
               ss <- fmap S.fromList (getChanContents snsChan)
               writeStrictListToChan picChan $ (map Just $ simulation ss) ++ [Nothing]
      forkIO simLoop
      let renderLoop = do
               maybePic <- readChan picChan
               case maybePic of
                 Just pic -> do
                         sampleSensor >>= writeChan snsChan
                         renderRoot pic
                         updateFPS fps
                         done <- exited
                         unless done renderLoop
                 Nothing -> return ()
      renderLoop
       

-------------------------------------------------------------------------------

